!#include  "PPR.INC"
C
C ************************************************************************
c exchanges*******************************************************
c exchanges*******************************************************
c exchanges*******************************************************
c exchanges*******************************************************
c exchanges*******************************************************
C----------------- SUBROUTINES FOR PARALLEL EXCHANGES -------------------
!#if parallel

c*************************************************************************


        SUBROUTINE MPA_EXCH(x,nxi,nxe,nyi,nye,nzi,nze,
     &                      nxsi,nxse,nysi,nyse,nzsi,nzse,
     &                      nxsh,nysh,nzsh,identif,
     &                      comm3d,req,nproc,ndim,
     &                      prplc)

       implicit none
       include 'mpif.h'
       integer identif
       integer comm3d,myrank,ierr,nproc,itag,iitag,ntag
       integer nx,ny,nz, nxi,nxe,nyi,nye,nzi,nze,i,j,k,is,js,ks
       integer nxsi,nxse,nysi,nyse,nzsi,nzse
       integer nxsh,nysh,nzsh
       integer nxir,nxer,nyir,nyer,nzir,nzer
       integer lbuf,ibuf,tag,rrank
       integer req(52,2000),req1(1000)
       integer status(MPI_STATUS_SIZE,52)
       integer status1(MPI_STATUS_SIZE)
       common /mpist/ status1
       integer ndim
       logical isperiodic(3),isperiodic1(3)
       integer dims(3),coords(3),coordn(3)
       integer testrank
       integer ireq
       integer ic
       integer prplc(26)
       integer
     &    irxpy0z0,irxmy0z0,irx0ypz0,irx0ymz0,
     &    irx0y0zp,irx0y0zm,irxpypz0,
     &    irxmypz0,irxpymz0,irxmymz0,irxpy0zp,
     &    irxpy0zm,irxmy0zp,irxmy0zm,
     &    irx0ypzp,irx0ypzm,irx0ymzp,irx0ymzm,
     &    irxpypzp,irxpymzp,irxpypzm,
     &    irxpymzm,irxmypzp,irxmymzp,irxmypzm,irxmymzm
       logical ans,flag
       logical MPA_BCHK
       real(kind=8) x(nxsi:nxse,nysi:nyse,nzsi:nzse)

       INTEGER IFN,IFK
       character(len=3) fn

       REAL(kind=8), allocatable :: xpy0z0(:),rxpy0z0(:)
       REAL(kind=8), allocatable :: x0ypz0(:),rx0ypz0(:)
       REAL(kind=8), allocatable :: x0y0zp(:),rx0y0zp(:)
       REAL(kind=8), allocatable :: xmy0z0(:),rxmy0z0(:)
       REAL(kind=8), allocatable :: x0ymz0(:),rx0ymz0(:)
       REAL(kind=8), allocatable :: x0y0zm(:),rx0y0zm(:)
       REAL(kind=8), allocatable :: xpypz0(:),rxpypz0(:)
       REAL(kind=8), allocatable :: xpymz0(:),rxpymz0(:)
       REAL(kind=8), allocatable :: xmypz0(:),rxmypz0(:)
       REAL(kind=8), allocatable :: xmymz0(:),rxmymz0(:)
       REAL(kind=8), allocatable :: xpy0zp(:),rxpy0zp(:)
       REAL(kind=8), allocatable :: xpy0zm(:),rxpy0zm(:)
       REAL(kind=8), allocatable :: xmy0zp(:),rxmy0zp(:)
       REAL(kind=8), allocatable :: xmy0zm(:),rxmy0zm(:)
       REAL(kind=8), allocatable :: x0ypzp(:),rx0ypzp(:)
       REAL(kind=8), allocatable :: x0ypzm(:),rx0ypzm(:)
       REAL(kind=8), allocatable :: x0ymzp(:),rx0ymzp(:)
       REAL(kind=8), allocatable :: x0ymzm(:),rx0ymzm(:)
       REAL(kind=8), allocatable :: xpypzp(:),rxpypzp(:)
       REAL(kind=8), allocatable :: xpymzp(:),rxpymzp(:)
       REAL(kind=8), allocatable :: xpypzm(:),rxpypzm(:)
       REAL(kind=8), allocatable :: xpymzm(:),rxpymzm(:)
       REAL(kind=8), allocatable :: xmypzp(:),rxmypzp(:)
       REAL(kind=8), allocatable :: xmymzp(:),rxmymzp(:)
       REAL(kind=8), allocatable :: xmypzm(:),rxmypzm(:)
       REAL(kind=8), allocatable :: xmymzm(:),rxmymzm(:)

      lbuf=(nze-nzi+1)*(nye-nyi+1)*nxsh
      allocate(xpy0z0(lbuf))
      allocate(xmy0z0(lbuf))
      allocate(rxpy0z0(lbuf))
      allocate(rxmy0z0(lbuf))
      lbuf=(nze-nzi+1)*(nxe-nxi+1)*nysh
      allocate(x0ypz0(lbuf))
      allocate(x0ymz0(lbuf))
      allocate(rx0ypz0(lbuf))
      allocate(rx0ymz0(lbuf))

      lbuf=(nye-nyi+1)*(nxe-nxi+1)*nzsh
      allocate(x0y0zp(lbuf))
      allocate(x0y0zm(lbuf))
      allocate(rx0y0zp(lbuf))
      allocate(rx0y0zm(lbuf))

      lbuf=(nze-nzi+1)*nysh*nxsh
       allocate (xpypz0(lbuf))
       allocate (rxpypz0(lbuf))
       allocate (xpymz0(lbuf))
       allocate (rxpymz0(lbuf))
       allocate (xmypz0(lbuf))
       allocate (rxmypz0(lbuf))
       allocate (xmymz0(lbuf))
       allocate (rxmymz0(lbuf))

      lbuf=(nye-nyi+1)*nzsh*nxsh
       allocate (xpy0zp(lbuf))
       allocate (rxpy0zp(lbuf))
       allocate (xpy0zm(lbuf))
       allocate (rxpy0zm(lbuf))
       allocate (xmy0zp(lbuf))
       allocate (rxmy0zp(lbuf))
       allocate (xmy0zm(lbuf))
       allocate (rxmy0zm(lbuf))

      lbuf=(nxe-nxi+1)*nzsh*nysh
       allocate (x0ypzp(lbuf))
       allocate (rx0ypzp(lbuf))
       allocate (x0ypzm(lbuf))
       allocate (rx0ypzm(lbuf))
       allocate (x0ymzp(lbuf))
       allocate (rx0ymzp(lbuf))
       allocate (x0ymzm(lbuf))
       allocate (rx0ymzm(lbuf))

      lbuf=nxsh*nzsh*nysh
       allocate (xpypzp(lbuf))
       allocate (rxpypzp(lbuf))
       allocate (xpymzp(lbuf))
       allocate (rxpymzp(lbuf))
       allocate (xpypzm(lbuf))
       allocate (rxpypzm(lbuf))
       allocate (xpymzm(lbuf))
       allocate (rxpymzm(lbuf))
       allocate (xmypzp(lbuf))
       allocate (rxmypzp(lbuf))
       allocate (xmymzp(lbuf))
       allocate (rxmymzp(lbuf))
       allocate (xmypzm(lbuf))
       allocate (rxmypzm(lbuf))
       allocate (xmymzm(lbuf))
       allocate (rxmymzm(lbuf))

       ireq=0

       isperiodic1(1)=.false.
       isperiodic1(2)=.false.
       isperiodic1(3)=.false.

!       call MPI_BARRIER(COMM3D,ierr)

       call MPI_COMM_RANK(comm3d,myrank,ierr)

       call MPI_Cart_get(comm3d, ndim, dims, isperiodic, coords,ierr)
c
c      sending boundary points
c
c      x-shift send
c
       lbuf=(nze-nzi+1)*(nye-nyi+1)*nxsh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if(prplc(1).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)
      coordn(3)=coords(3)

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      !write(*,*)'exch rank',myrank,'coords',coords,ans,coordn

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        ibuf=0
          do k=nzi,nze
          do j=nyi,nye
          do is=1,nxsh
            ibuf=ibuf+1
            xpy0z0(ibuf)=x(nxe-is+1,j,k)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1

       !write(ifn,*)'sendp1',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpy0z0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      coordn(1)=coords(1)-1
      coordn(2)=coords(2)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        tag=identif
        ireq=ireq+1

c      call MPI_BARRIER(comm3d,ierr)
       !write(ifn,*)'recvp1',myrank,rrank,tag,lbuf,ireq
        call MPI_irecv(rxpy0z0,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
        irxpy0z0=ireq
c      call MPI_BARRIER(comm3d,ierr)
       !write(ifn,*)'recvp1',myrank,'2'
      end if
c
      end if

c----------------------------------------------------------------
c      call MPI_BARRIER(comm3d,ierr)
       !write(ifn,*)'recvp1',myrank,'3'
      if(prplc(2).eq.1)then
c      call MPI_BARRIER(comm3d,ierr)
       !write(ifn,*)'recvp1',myrank,'4'

      coordn(1)=coords(1)-1
      coordn(2)=coords(2)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
c      call MPI_BARRIER(comm3d,ierr)
       !write(ifn,*)'recvp1',myrank,'5'
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
c      call MPI_BARRIER(comm3d,ierr)
       !write(ifn,*)'recvp1',myrank,'6'

        ibuf=0
          do k=nzi,nze
          do j=nyi,nye
          do is=1,nxsh
            ibuf=ibuf+1
       !write(ifn,*)'ibuf',myrank,ibuf
c      call MPI_BARRIER(comm3d,ierr)
            xmy0z0(ibuf)=x(nxi-1+is,j,k)
c      call MPI_BARRIER(comm3d,ierr)
       !write(ifn,*)'ibuf ibuf',myrank,ibuf
          end do
          end do
        end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvp1',myrank,'7'

       !write(ifn,*)'sendp2',myrank,rrank,tag,lbuf
       CALL MPI_isend(xmy0z0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
c----------------------------------------------------------------

      coordn(1)=coords(1)+1
      coordn(2)=coords(2)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvp2',myrank,rrank,tag,lbuf
        call MPI_irecv(rxmy0z0,lbuf,MPI_DOUBLE_PRECISION,
     &                 rrank,tag,comm3d,
     &                 req(ireq,identif),ierr)
        irxmy0z0=ireq
      end if
c
      end if
c
c******************************************************************
c      y-shift send
       lbuf=(nze-nzi+1)*(nxe-nxi+1)*nysh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if(prplc(3).eq.1)then
      coordn(2)=coords(2)+1
      coordn(1)=coords(1)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x0ypz0(ibuf)=x(i,nye-js+1,k)
          end do
          end do
          end do

       tag=identif
       ireq=ireq+1

        !write(ifn,*)'sendp3',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0ypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      coordn(2)=coords(2)-1
      coordn(1)=coords(1)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
        call MPI_irecv(rx0ypz0,lbuf,MPI_DOUBLE_PRECISION,
     &                 rrank,tag,comm3d,
     &                 req(ireq,identif),ierr)
        irx0ypz0=ireq
      end if
c
      end if
c----------------------------------------------------------------
      if(prplc(4).eq.1)then
c-------------------------------------------------------------------
      coordn(2)=coords(2)-1
      coordn(1)=coords(1)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x0ymz0(ibuf)=x(i,nyi+js-1,k)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendp4',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0ymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

        coordn(2)=coords(2)+1
        coordn(1)=coords(1)
        coordn(3)=coords(3)
       ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

       if(ans)then
        call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvp4',myrank,rrank,tag,lbuf
        call MPI_irecv(rx0ymz0,lbuf,MPI_DOUBLE_PRECISION,
     &                 rrank,tag,comm3d,
     &                 req(ireq,identif),ierr)
        irx0ymz0=ireq
      end if

      end if
c******************************************************************
c      z-shift send
       lbuf=(nye-nyi+1)*(nxe-nxi+1)*nzsh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      if(prplc(5).eq.1)then

      coordn(3)=coords(3)+1
      coordn(1)=coords(1)
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do i=nxi,nxe
           ibuf=ibuf+1
           x0y0zp(ibuf)=x(i,j,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendp5',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0y0zp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
c      !write(*,*)'sent planes 1',myrank,rrank,tag
      end if
      coordn(3)=coords(3)-1
      coordn(1)=coords(1)
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvp5',myrank,rrank,tag,lbuf
        call MPI_irecv(rx0y0zp,lbuf,MPI_DOUBLE_PRECISION,
     &                 rrank,tag,comm3d,
     &                 req(ireq,identif),ierr)
        irx0y0zp=ireq
      end if

      end if
c-------------------------------------------------------------------
      if(prplc(6).eq.1)then
      coordn(3)=coords(3)-1
      coordn(1)=coords(1)
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do i=nxi,nxe
           ibuf=ibuf+1
           x0y0zm(ibuf)=x(i,j,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendp6',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0y0zm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
c      !write(*,*)'sent planes 2',myrank,rrank,tag
      end if

        coordn(3)=coords(3)+1
        coordn(1)=coords(1)
        coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      
      
      if(ans)then
        call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvp6',myrank,rrank,tag,lbuf
        call MPI_irecv(rx0y0zm,lbuf,MPI_DOUBLE_PRECISION,
     &                 rrank,tag,comm3d,
     &                 req(ireq,identif),ierr)
        irx0y0zm=ireq
      end if
c
      end if
c      xy-shift send
c
       lbuf=(nze-nzi+1)*nysh*nxsh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      if(prplc(7).eq.1)then

      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xpypz0(ibuf)=x(nxe-is+1,nye-js+1,k)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl1',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl1',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpypz0,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxpypz0=ireq
      end if

      end if
c----------------------------------------------------------------
c
c+++++++++++++++++++++++++++++-----------------------------------

      if(prplc(8).eq.1)then

      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xpymz0(ibuf)=x(nxe-is+1,nyi+js-1,k)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1

       !write(ifn,*)'sendl2',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
c++++++++++++++++++++++-----------------------------------------

      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl2',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpymz0,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxpymz0=ireq
      end if
c
      end if
c----------------------------------------------------------------
c-----------------------------+++++++++++++++++++++++++++++++++++

      if(prplc(9).eq.1)then

      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xmypz0(ibuf)=x(nxi+is-1,nye-js+1,k)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl3',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl3',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmypz0,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxmypz0=ireq

      end if
c
      end if
c----------------------------------------------------------------
c-----------------------------    ------------------------------

      if(prplc(10).eq.1)then

      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xmymz0(ibuf)=x(nxi+is-1,nyi+js-1,k)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl4',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl4',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmymz0,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irxmymz0=ireq
      end if
c
      end if
c----------------------------------------------------------------
c
c      xz-shift send
c
       lbuf=(nye-nyi+1)*nzsh*nxsh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if(prplc(11).eq.1)then
      coordn(1)=coords(1)+1
      coordn(3)=coords(3)+1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           xpy0zp(ibuf)=x(nxe-is+1,j,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl5',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpy0zp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
c     !write(*,*)'pps', myrank,rrank,tag
      end if

      coordn(1)=coords(1)-1
      coordn(3)=coords(3)-1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
c     !write(*,*)'ppr', myrank,rrank,tag
       !write(ifn,*)'recvl5',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpy0zp,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irxpy0zp=ireq
      end if
c
      end if
c----------------------------------------------------------------
c
c+++++++++++++++++++++++++++++-----------------------------------

      if(prplc(12).eq.1)then
      coordn(1)=coords(1)+1
      coordn(3)=coords(3)-1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
            ibuf=ibuf+1
            xpy0zm(ibuf)=x(nxe-is+1,j,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl6',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpy0zm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
c     !write(*,*)'pms', myrank,rrank,tag
      end if
      coordn(1)=coords(1)-1
      coordn(3)=coords(3)+1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
c     !write(*,*)'pmr', myrank,rrank,tag
       !write(ifn,*)'recvl6',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpy0zm,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irxpy0zm=ireq
      end if
c
      end if
c----------------------------------------------------------------
c-----------------------------+++++++++++++++++++++++++++++++++++
      if(prplc(13).eq.1)then
      coordn(1)=coords(1)-1
      coordn(3)=coords(3)+1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
           ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           xmy0zp(ibuf)=x(nxi+is-1,j,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl7',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmy0zp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
c     !write(*,*)'mps', myrank,rrank,tag
      end if
      coordn(1)=coords(1)+1
      coordn(3)=coords(3)-1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
c     !write(*,*)'mpr', myrank,rrank,tag
       !write(ifn,*)'recvl7',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmy0zp,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irxmy0zp=ireq
      end if
c
      end if
c----------------------------------------------------------------
c-----------------------------    ------------------------------

      if(prplc(14).eq.1)then
c
      coordn(1)=coords(1)-1
      coordn(3)=coords(3)-1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           xmy0zm(ibuf)=x(nxi+is-1,j,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl8',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmy0zm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
c     !write(*,*)'mms', myrank,rrank,tag
      end if
      coordn(1)=coords(1)+1
      coordn(3)=coords(3)+1
      coordn(2)=coords(2)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
c     !write(*,*)'mmr', myrank,rrank,tag
       !write(ifn,*)'recvl8',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmy0zm,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxmy0zm=ireq
      end if
c
      end if
c----------------------------------------------------------------
c----------------------------------------------------------------
c
c      yz-shift send
c
       lbuf=(nxe-nxi+1)*nzsh*nysh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      if(prplc(15).eq.1)then

      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x0ypzp(ibuf)=x(i,nye-js+1,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl9',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0ypzp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl9',myrank,rrank,tag,lbuf
      call MPI_irecv(rx0ypzp,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irx0ypzp=ireq
      end if
c
      end if
c----------------------------------------------------------------
c
c+++++++++++++++++++++++++++++-----------------------------------

      if(prplc(16).eq.1)then
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
            ibuf=ibuf+1
            x0ypzm(ibuf)=x(i,nye-js+1,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl10',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0ypzm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl10',myrank,rrank,tag,lbuf
      call MPI_irecv(rx0ypzm,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irx0ypzm=ireq
      end if
      end if

c----------------------------------------------------------------
c-----------------------------+++++++++++++++++++++++++++++++++++
      if(prplc(17).eq.1)then
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x0ymzp(ibuf)=x(i,nyi+js-1,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl11',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0ymzp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl11',myrank,rrank,tag,lbuf
      call MPI_irecv(rx0ymzp,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irx0ymzp=ireq
      end if
      end if
c----------------------------------------------------------------
c-----------------------------    ------------------------------

      if(prplc(18).eq.1)then
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x0ymzm(ibuf)=x(i,nyi+js-1,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendl12',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(x0ymzm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1
      coordn(1)=coords(1)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvl12',myrank,rrank,tag,lbuf
      call MPI_irecv(rx0ymzm,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irx0ymzm=ireq
      end if
c
      end if
c
c
c      !write(*,*)'sent lines',myrank,ireq
c-------------- xyz-------------shift--------------------------
       lbuf=nxsh*nzsh*nysh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if(prplc(19).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xpypzp(ibuf)=x(nxe-is+1,nye-js+1,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc1',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpypzp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc1',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpypzp,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irxpypzp=ireq
      end if
      end if


c++++++ +++++++ ------

      if(prplc(20).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xpypzm(ibuf)=x(nxe-is+1,nye-js+1,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc2',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpypzm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc2',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpypzm,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxpypzm=ireq
      end if
      end if

c++++++ ------ ++++++

      if(prplc(21).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xpymzp(ibuf)=x(nxe-is+1,nyi+js-1,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc3',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpymzp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc3',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpymzp,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxpymzp=ireq
      end if
      end if


c++++++ ------ -------

      if(prplc(22).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xpymzm(ibuf)=x(nxe-is+1,nyi+js-1,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc4',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xpymzm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc4',myrank,rrank,tag,lbuf
      call MPI_irecv(rxpymzm,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxpymzm=ireq
      end if
      end if


c------     +++++++++   ++++++

      if(prplc(23).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xmypzp(ibuf)=x(nxi+is-1,nye-js+1,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc5',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmypzp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc5',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmypzp,lbuf,MPI_DOUBLE_PRECISION,
     &                rrank,tag,comm3d,
     &                req(ireq,identif),ierr)
      irxmypzp=ireq
      end if
c
      end if


c------ +++++++ ------

      if(prplc(24).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xmypzm(ibuf)=x(nxi+is-1,nye-js+1,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc6',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmypzm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc6',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmypzm,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxmypzm=ireq
      end if
      end if

c------ ------ ++++++

      if(prplc(25).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xmymzp(ibuf)=x(nxi+is-1,nyi+js-1,nze-ks+1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc7',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmymzp,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc7',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmymzp,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxmymzp=ireq
      end if
      end if


c----- ------ -------

      if(prplc(26).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           xmymzm(ibuf)=x(nxi+is-1,nyi+js-1,nzi+ks-1)
          end do
          end do
          end do
       tag=identif
       ireq=ireq+1
       !write(ifn,*)'sendc8',myrank,rrank,tag,lbuf,ireq
       CALL MPI_isend(xmymzm,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
     &                comm3d,req(ireq,identif),ierr)
       !call mpi_request_free(req1(myrank+1),ierr)
      end if

      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1

      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)

      if(ans)then
      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

       tag=identif
       ireq=ireq+1
       !write(ifn,*)'recvc8',myrank,rrank,tag,lbuf
      call MPI_irecv(rxmymzm,lbuf,MPI_DOUBLE_PRECISION,
     &               rrank,tag,comm3d,
     &               req(ireq,identif),ierr)
      irxmymzm=ireq
      end if
      end if
c      write(*,*)'exch out',identif,' rank ',myrank
C*******************************************************************
C      call MPI_BARRIER(comm3d,ierr)
c      call MPA_SYNC(comm3d,nproc,identif)
      do i = 1,ireq
        call MPI_WAIT(req(i,identif), STATUS1, IERR)
c        IFN=100+MYRANK+1
c        write(ifn,*)' dozhdalsya',myrank,i
      enddo

!      call MPI_BARRIER(comm3d,ierr)

C*******************************************************************


      if(prplc(1).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
      ic=ic+1
          ibuf=0
          do k=nzi,nze
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,j,k)=rxpy0z0(ibuf)
          end do
          end do
          end do
       end if
       end if

      if(prplc(2).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do k=nzi,nze
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,j,k)=rxmy0z0(ibuf)
          end do
          end do
          end do
       end if
       end if
c
      if(prplc(3).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x(i,nyi-js,k)=rx0ypz0(ibuf)
          end do
          end do
          end do
       end if
       end if

      if(prplc(4).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x(i,nye+js,k)=rx0ymz0(ibuf)
          end do
          end do
          end do
       end if
       end if
c
      if(prplc(5).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do i=nxi,nxe
           ibuf=ibuf+1
           x(i,j,nzi-ks)=rx0y0zp(ibuf)
          end do
          end do
          end do
       end if
       end if

      if(prplc(6).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
           do ks=1,nzsh
           do j=nyi,nye
           do i=nxi,nxe
            ibuf=ibuf+1
            x(i,j,nze+ks)=rx0y0zm(ibuf)
           end do
           end do
           end do
        end if
        end if

c--------xy------------xy-------------xy-------------xy-------------
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if(prplc(7).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,nyi-js,k)=rxpypz0(ibuf)
          end do
          end do
        end do
       end if
       end if
c++++++++++++++++++++++++++++++--------------------------------------

      if(prplc(8).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,nye+js,k)=rxpymz0(ibuf)
          end do
          end do
        end do
       end if
       end if
c---------------------------------++++++++++++++++++++++++++++++++++
      if(prplc(9).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,nyi-js,k)=rxmypz0(ibuf)
          end do
          end do
          end do
       end if
       end if
c---------------------------------   --------------------------------
      if(prplc(10).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do k=nzi,nze
          do js=1,nysh
          do is=1,nxsh
            ibuf=ibuf+1
            x(nxe+is,nye+js,k)=rxmymz0(ibuf)
          end do
          end do
          end do
       end if
       end if
c
c--------xz------------xz-------------xz-------------xz-------------
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if(prplc(11).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,j,nzi-ks)=rxpy0zp(ibuf)
          end do
          end do
          end do
       end if
       end if
c++++++++++++++++++++++++++++++--------------------------------------
      if(prplc(12).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,j,nze+ks)=rxpy0zm(ibuf)
          end do
          end do
          end do
       end if
       end if
c---------------------------------++++++++++++++++++++++++++++++++++
      if(prplc(13).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,j,nzi-ks)=rxmy0zp(ibuf)
          end do
          end do
          end do
       end if
       end if
c---------------------------------   --------------------------------
      if(prplc(14).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do ks=1,nzsh
          do j=nyi,nye
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,j,nze+ks)=rxmy0zm(ibuf)
          end do
          end do
          end do
       end if
       end if

c--------yz------------yz-------------yz-------------yz-------------
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      if(prplc(15).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then

        ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x(i,nyi-js,nzi-ks)=rx0ypzp(ibuf)
          end do
          end do
          end do
       end if
       end if
c++++++++++++++++++++++++++++++--------------------------------------

      if(prplc(16).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x(i,nyi-js,nze+ks)=rx0ypzm(ibuf)
          end do
          end do
          end do
       end if
       end if
c---------------------------------++++++++++++++++++++++++++++++++++
      if(prplc(17).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x(i,nye+js,nzi-ks)=rx0ymzp(ibuf)
          end do
          end do
          end do
       end if
       end if
c---------------------------------   --------------------------------

      if(prplc(18).eq.1)then
      coordn(1)=coords(1)
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do i=nxi,nxe
           ibuf=ibuf+1
           x(i,nye+js,nze+ks)=rx0ymzm(ibuf)
          end do
          end do
          end do
       end if
       end if
c
c--------xyz------------xyz-------------xyz-------------xyz---------
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      if(prplc(19).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,nyi-js,nzi-ks)=rxpypzp(ibuf)
          end do
          end do
          end do
       end if
       end if
c ++++++ +++++++ --------
      if(prplc(20).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,nyi-js,nze+ks)=rxpypzm(ibuf)
          end do
          end do
        end do
       end if
       end if
c
c ++++++ ------- +++++++
      if(prplc(21).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,nye+js,nzi-ks)=rxpymzp(ibuf)
          end do
          end do
          end do
       end if
       end if
cc ++++++ ------- --------
      if(prplc(22).eq.1)then
      coordn(1)=coords(1)-1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxi-is,nye+js,nze+ks)=rxpymzm(ibuf)
          end do
          end do
          end do
       end if
       end if
c
c------     ++++++++   +++++++
      if(prplc(23).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,nyi-js,nzi-ks)=rxmypzp(ibuf)
          end do
          end do
          end do
       end if
       end if
c ++++++ +++++++ --------
      if(prplc(24).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)-1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
        ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,nyi-js,nze+ks)=rxmypzm(ibuf)
          end do
          end do
          end do
       end if
       end if
c
c ------- ------- +++++++
      if(prplc(25).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)-1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,nye+js,nzi-ks)=rxmymzp(ibuf)
          end do
          end do
          end do
       end if
       end if
cc -------- ------- --------
      if(prplc(26).eq.1)then
      coordn(1)=coords(1)+1
      coordn(2)=coords(2)+1
      coordn(3)=coords(3)+1
      ans=MPA_BCHK(isperiodic1,dims,coordn,coords,nxsh,nysh,nzsh)
      if(ans)then
          ibuf=0
          do ks=1,nzsh
          do js=1,nysh
          do is=1,nxsh
           ibuf=ibuf+1
           x(nxe+is,nye+js,nze+ks)=rxmymzm(ibuf)
          end do
          end do
          end do
       end if
       end if
c      call MPI_BARRIER(comm3d,ierr)
c        write(*,*)'exch out',identif,' rank ',myrank
       !close(IFN)
               deallocate (rxmymzm)
               deallocate (rxmypzm)
               deallocate (rxmymzp)
               deallocate (rxmypzp)
       deallocate (rxpymzm)
       deallocate (rxpypzm)
       deallocate (rxpymzp)
       deallocate (rxpypzp)
               deallocate (rx0ymzm)
               deallocate (rx0ymzp)
               deallocate (rx0ypzm)
               deallocate (rx0ypzp)
        deallocate (rxmy0zm)
        deallocate (rxmy0zp)
        deallocate (rxpy0zm)
        deallocate (rxpy0zp)
                deallocate (rxmymz0)
                deallocate (rxpymz0)
                deallocate (rxmypz0)
                deallocate (rxpypz0)
        deallocate(rx0y0zm)
        deallocate(rx0y0zp)
        deallocate(rx0ymz0)
        deallocate(rx0ypz0)
        deallocate(rxmy0z0)
        deallocate(rxpy0z0)
               deallocate (xmymzm)
               deallocate (xmypzm)
               deallocate (xmymzp)
               deallocate (xmypzp)
       deallocate (xpymzm)
       deallocate (xpypzm)
       deallocate (xpymzp)
       deallocate (xpypzp)
               deallocate (x0ymzm)
               deallocate (x0ymzp)
               deallocate (x0ypzm)
               deallocate (x0ypzp)
        deallocate (xmy0zm)
        deallocate (xmy0zp)
        deallocate (xpy0zm)
        deallocate (xpy0zp)
                deallocate (xmymz0)
                deallocate (xpymz0)
                deallocate (xmypz0)
                deallocate (xpypz0)
        deallocate(x0y0zm)
        deallocate(x0y0zp)
        deallocate(x0ymz0)
        deallocate(x0ypz0)
        deallocate(xpy0z0)
        deallocate(xmy0z0)

        return
        END SUBROUTINE MPA_EXCH
c**********************************************************************


        FUNCTION MPA_BCHK(isperiodic,dims,coordn,coords,
     &                             nxsh,nysh,nzsh)

        implicit none

        logical :: MPA_BCHK
        logical isperiodic(3)
        integer dims(3),coordn(3),shift(3),coords(3)
        integer i,nxsh,nysh,nzsh
        logical ans,ins
        shift(1)=nxsh
        shift(2)=nysh
        shift(3)=nzsh
        c1: do i = 1,3
          ins=(coordn(i)+1.le.dims(i)).and.coordn(i).ge.0
          if (ins .or.isperiodic(i) ) then
            ans=.true.
          else
            ans=.false.
            exit c1
          end if
        end do c1
        do i = 1,3
          if ((coords(i).ne.coordn(i)).and. shift(i).eq.0)then
            ans=.false.
          end if
        end do
        MPA_BCHK=ans
        return
        END FUNCTION MPA_BCHK


C      subroutine MPA_exchxy(x,nxi,nxe,nyi,nye,nzi,nze,
C     &                      nxsh,nysh,nzsh,ze,identife,
C     &                      comm3d,nproc,ndim,req,
C     &  xy_xpy0z0,rxy_xpy0z0,
C     &  xy_x0ypz0,rxy_x0ypz0,
C     &  xy_xmy0z0,rxy_xmy0z0,
C     &  xy_x0ymz0,rxy_x0ymz0,
C     &  xy_xpypz0,rxy_xpypz0,
C     &  xy_xpymz0,rxy_xpymz0,
C     &  xy_xmypz0,rxy_xmypz0,
C     &  xy_xmymz0,rxy_xmymz0 )


      SUBROUTINE MPA_EXCHXY(x,nxi,nxe,nyi,nye,nzi,nze,
     &                      nxsh,nysh,nzsh,ze,identife,
     &                      comm3d,nproc,ndim,req2,prplc, 
     &                      request_send,request_recv)
       implicit none
       include 'mpif.h'
       integer identif,identife
       integer comm3d,myrank,ierr,nproc,itag,iitag,ntag
       integer nx,ny,nz, nxi,nxe,nyi,nye,nzi,nze,i,j,is,js
       integer nxsh,nysh,nzsh,ze
       integer nxir,nxer,nyir,nyer,nzir,nzer
       integer lbuf,tag,rrank
       integer status(MPI_STATUS_SIZE)
       integer req2(1000),req(16,2000:4001)
       integer prplc(1:8)
       integer ndim
       logical isperiodic(3)
       integer dims(3),coords(3),coordn(3)
       integer testrank
       integer ireq
       integer, intent(inout) :: request_send(1:8)
       integer, intent(inout) :: request_recv(1:8)
       logical ans
       logical MPA_BCHK
       logical, save :: ansar(1:8)
       logical, save :: firstcall
       real(kind=8)
     &     x(nxi-nxsh:nxe+nxsh,nyi-nysh:nye+nysh,nzi-nzsh:nze+nzsh)
       double precision tmr1,tmr2,tmr_exy

       data firstcall /.true./

       REAL(kind=8),allocatable,save :: xy_xpy0z0(:,:),rxy_xpy0z0(:,:)
       REAL(kind=8),allocatable,save :: xy_x0ypz0(:,:),rxy_x0ypz0(:,:)
       REAL(kind=8),allocatable,save :: xy_xmy0z0(:,:),rxy_xmy0z0(:,:)
       REAL(kind=8),allocatable,save :: xy_x0ymz0(:,:),rxy_x0ymz0(:,:)

       REAL(kind=8),allocatable,save :: xy_xpypz0(:,:),rxy_xpypz0(:,:)
       REAL(kind=8),allocatable,save :: xy_xpymz0(:,:),rxy_xpymz0(:,:)
       REAL(kind=8),allocatable,save :: xy_xmypz0(:,:),rxy_xmypz0(:,:)
       REAL(kind=8),allocatable,save :: xy_xmymz0(:,:),rxy_xmymz0(:,:)

!#if timer
!        INCLUDE 'TMR_EXY.CMB'     !TIMER
!#endif

      if (firstcall) then
        allocate(xy_xpy0z0(nyi:nye,nxsh))
        allocate(xy_xmy0z0(nyi:nye,nxsh))
        allocate(rxy_xpy0z0(nyi:nye,nxsh))
        allocate(rxy_xmy0z0(nyi:nye,nxsh))

        allocate(xy_x0ypz0(nxi:nxe,nysh))
        allocate(xy_x0ymz0(nxi:nxe,nysh))
        allocate(rxy_x0ypz0(nxi:nxe,nysh))
        allocate(rxy_x0ymz0(nxi:nxe,nysh))

        allocate (xy_xpypz0(nxsh,nysh))
        allocate (rxy_xpypz0(nxsh,nysh))
        allocate (xy_xpymz0(nxsh,nysh))
        allocate (rxy_xpymz0(nxsh,nysh))
        allocate (xy_xmypz0(nxsh,nysh))
        allocate (rxy_xmypz0(nxsh,nysh))
        allocate (xy_xmymz0(nxsh,nysh))
        allocate (rxy_xmymz0(nxsh,nysh))
      endif 

!#if timer
!        tmr1=MPI_WTIME()
!#endif

!       call MPI_BARRIER(COMM3D, ierr)

!       call MPI_COMM_RANK(comm3d,myrank,ierr)

       identif=identife


      ireq = 0
      if(ze.ge.(nzi-nzsh).and.ze.le.(nze+nzsh))then


       call MPI_CART_GET(comm3d, ndim, dims, isperiodic, coords,ierr)
       call MPI_COMM_RANK(comm3d,myrank,ierr)

c
c      sending boundary points
c
c      x-shift send
c
       lbuf=(nye-nyi+1)*nxsh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


!     Initialization of send request
      if (firstcall) then 
        coordn(1)=coords(1)+1
        coordn(2)=coords(2)
        coordn(3)=coords(3)
        ansar(1) = 
     &   MPA_BCHK(isperiodic,dims,coordn,coords,nxsh,nysh,nzsh)
        if (ansar(1)) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_xpy0z0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(1), ierr)
        endif
      endif
       
      if (prplc(1) == 1) then ! sending right x-edge to the right neighbour
 
      if (ansar(1)) then
!       call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        do is=1,nxsh
          do j=nyi,nye
            xy_xpy0z0(j,is)=x(nxe-is+1,j,ze)
          end do
        end do
        
        call MPI_START(request_send(1), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(1)

!        CALL MPI_isend(xy_xpy0z0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)
      end if

      end if

c----------------------------------------------------------------

!     Initialization of send request
      if (firstcall) then 
        coordn(1)=coords(1)-1
        coordn(2)=coords(2)
        coordn(3)=coords(3)
        ansar(2) =
     &   MPA_BCHK(isperiodic,dims,coordn,coords,nxsh,nysh,nzsh)
        if (ansar(2)) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_xmy0z0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(2), ierr) 
        endif
      endif

      if (prplc(2)==1) then !sending left x-edge to the left neighbour 

      if (ansar(2)) then
!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        do is=1,nxsh
          do j=nyi,nye
            xy_xmy0z0(j,is)=x(nxi-1+is,j,ze)
          end do
        end do

        call MPI_START(request_send(2), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(2)

!       CALL MPI_isend(xy_xmy0z0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)
      end if

      end if

c******************************************************************
c      y-shift send
       lbuf=(nxe-nxi+1)*nysh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!     Initialization of send request
      if (firstcall) then
        coordn(2)=coords(2)+1
        coordn(1)=coords(1)
        coordn(3)=coords(3)
        ansar(3) = 
     &   MPA_BCHK(isperiodic, dims, coordn, coords, nxsh, nysh, nzsh)
        if (ansar(3)) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_x0ypz0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(3), ierr)
        endif
      endif

      if (prplc(3)==1) then !sending upper y-edge to the upper neighbour 

      if (ansar(3)) then
!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        do is=1,nysh
          do i=nxi,nxe
            xy_x0ypz0(i,is)=x(i,nye-is+1,ze)
          end do
        end do

        call MPI_START(request_send(3), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(3)


!       CALL MPI_isend(xy_x0ypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)

      end if

      end if

c-------------------------------------------------------------------

!     Initialization of send request
      if (firstcall) then
        coordn(2)=coords(2)-1
        coordn(1)=coords(1)
        coordn(3)=coords(3)
        ansar(4) = 
     &   MPA_BCHK(isperiodic, dims, coordn, coords, nxsh, nysh, nzsh)
        if ( ansar(4) ) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_x0ymz0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(4), ierr)
        endif
      endif

      if (prplc(4)==1) then !sending lower y-edge to the lower neighbour
 
      if (ansar(4)) then
!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)
        do is=1,nysh
          do i=nxi,nxe
            xy_x0ymz0(i,is)=x(i,nyi+is-1,ze)
          end do
        end do

        call MPI_START(request_send(4), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(4)


!       CALL MPI_isend(xy_x0ymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)

      end if

      end if

c      xy-shift send
c
       lbuf=nysh*nxsh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!     Initialization of send request
      if (firstcall) then
        coordn(1)=coords(1)+1
        coordn(2)=coords(2)+1
        coordn(3)=coords(3)
        ansar(5) = 
     &   MPA_BCHK(isperiodic, dims, coordn, coords, nxsh, nysh, nzsh)
        if (ansar(5)) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_xpypz0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(5), ierr)
        endif
      endif

      if (prplc(5)==1) then !sending upper-right corner to the upper-right neighbour

      if (ansar(5)) then
!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        do js=1,nysh
          do is=1,nxsh
            xy_xpypz0(is,js)=x(nxe-is+1,nye-js+1,ze)
          end do
        end do

        call MPI_START(request_send(5), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(5)


!       CALL MPI_isend(xy_xpypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)

      end if

      end if

c----------------------------------------------------------------
c
c+++++++++++++++++++++++++++++-----------------------------------

!     Initialization of send request
      if (firstcall) then
        coordn(1)=coords(1)+1
        coordn(2)=coords(2)-1
        coordn(3)=coords(3)
        ansar(7) = 
     &   MPA_BCHK(isperiodic,dims,coordn,coords,nxsh,nysh,nzsh)
        if (ansar(7)) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_xpymz0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(7), ierr)
        endif
      endif

      if (prplc(7)==1) then !sending lower-right corner to the lower-right neighbour

      if (ansar(7)) then
!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        do js=1,nysh
          do is=1,nxsh
            xy_xpymz0(is,js)=x(nxe-is+1,nyi+js-1,ze)
          end do
        end do

        call MPI_START(request_send(7), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(7)


!       CALL MPI_isend(xy_xpymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)

      end if

      endif

c----------------------------------------------------------------
c-----------------------------+++++++++++++++++++++++++++++++++++

!     Initialization of send request
      if (firstcall) then
        coordn(1)=coords(1)-1
        coordn(2)=coords(2)+1
        coordn(3)=coords(3)
        ansar(6) = 
     &   MPA_BCHK(isperiodic, dims, coordn, coords, nxsh, nysh, nzsh)
        if (ansar(6)) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_xmypz0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(6), ierr)
        endif
      endif


      if (prplc(6)==1) then !sending upper-left corner to the upper-left neighbour

      if(ansar(6))then
!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        do js=1,nysh
          do is=1,nxsh
            xy_xmypz0(is,js)=x(nxi+is-1,nye-js+1,ze)
          end do
        end do

        call MPI_START(request_send(6), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(6)


!       CALL MPI_isend(xy_xmypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)

      end if

      end if

c----------------------------------------------------------------
c-----------------------------    ------------------------------

!     Initialization of send request
      if (firstcall) then
        coordn(1)=coords(1)-1
        coordn(2)=coords(2)-1
        coordn(3)=coords(3)
        ansar(8) = 
     &   MPA_BCHK(isperiodic,dims,coordn,coords,nxsh,nysh,nzsh)
        if (ansar(8)) then
          tag = identif
          call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
          call MPI_SEND_INIT(xy_xmymz0, lbuf, MPI_DOUBLE_PRECISION,
     &     rrank, tag, comm3d, request_send(8), ierr)
        endif
      endif

      if (prplc(8)==1) then !sending lower-left corner to the lower-left neighbour

      if (ansar(8)) then
!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        do js=1,nysh
          do is=1,nxsh
            xy_xmymz0(is,js)=x(nxi+is-1,nyi+js-1,ze)
          end do
        end do

        call MPI_START(request_send(8), ierr)

        ireq = ireq + 1
        req2(ireq) = request_send(8)


!       CALL MPI_isend(xy_xmymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,tag,
!     &                comm3d,req(ireq,identif),ierr)
!       call mpi_request_free(req(myrank+1),ierr)

      end if

      end if

      end if

!       call MPI_BARRIER(comm3d,ierr)

       if(ze.ge.(nzi-nzsh).and.ze.le.(nze+nzsh))then

c----------------------------------------------------------------
c
c      receiving boundary points
c----------------------------------------------------------------
c
c----------------------------------------------------------------
c      x-shift receive
c
      lbuf=(nye-nyi+1)*nxsh
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if (firstcall.and.ansar(2)) then
        coordn(1)=coords(1)-1
        coordn(2)=coords(2)
        coordn(3)=coords(3)
        tag = identif
        call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
        call MPI_RECV_INIT(rxy_xpy0z0, lbuf, MPI_DOUBLE_PRECISION,
     &                rrank, tag, comm3d,
     &                request_recv(1), ierr)
       
      endif

      if (prplc(1)==1) then

      if (ansar(2)) then

        call MPI_START(request_recv(1), ierr)

!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(1)


!        call MPI_iRECV(rxy_xpy0z0,lbuf,MPI_DOUBLE_PRECISION,
!     &                rrank,tag,comm3d,
!     &                req(ireq,identif),ierr)

      end if

      endif

c----------------------------------------------------------------

       if (firstcall.and.ansar(1)) then
         coordn(1)=coords(1)+1
         coordn(2)=coords(2)
         coordn(3)=coords(3)
         tag = identif
         call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
         call MPI_RECV_INIT(rxy_xmy0z0, lbuf, MPI_DOUBLE_PRECISION,
     &                rrank, tag, comm3d,
     &                request_recv(2),ierr)       
       endif

      if (prplc(2)==1) then

      if (ansar(1)) then

        call MPI_START(request_recv(2), ierr)

!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(2)


!        call MPI_iRECV(rxy_xmy0z0,lbuf,MPI_DOUBLE_PRECISION,
!     &                rrank,tag,comm3d,
!     &                req(ireq,identif),ierr)

      end if

      end if

c******************************************************************
c      y-shift recive
        lbuf=(nxe-nxi+1)*nysh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if (firstcall.and.ansar(4)) then
        coordn(2)=coords(2)-1
        coordn(1)=coords(1)
        coordn(3)=coords(3)
        tag = identif
        call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
        call MPI_RECV_INIT(rxy_x0ypz0, lbuf, MPI_DOUBLE_PRECISION,
     &                 rrank, tag, comm3d,
     &                 request_recv(3),ierr)

      endif

      if (prplc(3)==1) then

      if (ansar(4)) then

        call MPI_START(request_recv(3), ierr)

!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(3)


!        call MPI_iRECV(rxy_x0ypz0,lbuf,MPI_DOUBLE_PRECISION,
!     &                 rrank,tag,comm3d,
!     &                 req(ireq,identif),ierr)
      end if

      end if

c----------------------------------------------------------------

      if (firstcall.and.ansar(3)) then
        coordn(2)=coords(2)+1
        coordn(1)=coords(1)
        coordn(3)=coords(3)
        tag = identif
        call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
        call MPI_RECV_INIT(rxy_x0ymz0, lbuf, MPI_DOUBLE_PRECISION,
     &                rrank, tag, comm3d,
     &                request_recv(4), ierr)
      endif

      if (prplc(4)==1) then
      if (ansar(3)) then

        call MPI_START(request_recv(4), ierr)

!        call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(4)


!        call MPI_iRECV(rxy_x0ymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,
!     &                tag,comm3d,
!     &                req(ireq,identif),ierr)

      end if
      end if

c      xy-shift recive
c
       lbuf=nysh*nxsh
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if (firstcall.and.ansar(8)) then
        coordn(1)=coords(1)-1
        coordn(2)=coords(2)-1
        coordn(3)=coords(3)
        tag = identif
        call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
        call MPI_RECV_INIT(rxy_xpypz0, lbuf, MPI_DOUBLE_PRECISION,
     &   rrank, tag, comm3d,
     &   request_recv(5), ierr)
      endif

      if (prplc(5)==1) then
      if (ansar(8)) then

        call MPI_START(request_recv(5), ierr)

!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(5)

!      call MPI_iRECV(rxy_xpypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,
!     &              tag,comm3d,
!     &              req(ireq,identif),ierr)

      end if
      end if

c----------------------------------------------------------------
c++++++++++++++++++++++-----------------------------------------

      if (firstcall.and.ansar(6)) then
        coordn(1)=coords(1)-1
        coordn(2)=coords(2)+1
        coordn(3)=coords(3)
        tag = identif
        call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
        call MPI_RECV_INIT(rxy_xpymz0, lbuf, MPI_DOUBLE_PRECISION, 
     &   rrank, tag, comm3d,
     &   request_recv(7), ierr)
      endif

      if (prplc(7)==1) then
      if (ansar(6)) then

        call MPI_START(request_recv(7),ierr)

!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(7)

!      call MPI_iRECV(rxy_xpymz0,lbuf,MPI_DOUBLE_PRECISION,rrank,
!     &              tag,comm3d,
!     &              req(ireq,identif),ierr)

      end if
      end if

c----------------------------------------------------------------

c-----------------------------------+++++++++++++++++++++++++++++

      if (firstcall.and.ansar(7)) then
        coordn(1)=coords(1)+1
        coordn(2)=coords(2)-1
        coordn(3)=coords(3)
        tag = identif
        call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
        call MPI_RECV_INIT(rxy_xmypz0, lbuf, MPI_DOUBLE_PRECISION, 
     &   rrank, tag, comm3d,
     &   request_recv(6), ierr)
      endif

      if (prplc(6)==1) then
      if (ansar(7)) then

        call MPI_START(request_recv(6), ierr)

!       call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(6)

!      call MPI_iRECV(rxy_xmypz0,lbuf,MPI_DOUBLE_PRECISION,rrank,
!     &              tag,comm3d,
!     &              req(ireq,identif),ierr)

      end if
      end if

c----------------------------------------------------------------
c----------------------------- ----------------------------------

      if (firstcall.and.ansar(5)) then
        coordn(1)=coords(1)+1
        coordn(2)=coords(2)+1
        coordn(3)=coords(3)
        tag = identif
        call MPI_CART_RANK(comm3d, coordn, rrank, ierr)
        call MPI_RECV_INIT(rxy_xmymz0, lbuf, MPI_DOUBLE_PRECISION,
     &   rrank, tag, comm3d,
     &   request_recv(8),ierr)
      endif
 

      if (prplc(8)==1) then
      if (ansar(5)) then

        call MPI_START(request_recv(8), ierr)

!      call MPI_CART_RANK(comm3d,coordn,rrank,ierr)

        ireq = ireq + 1
        req2(ireq) = request_recv(8)

!      call MPI_iRECV(rxy_xmymz0,lbuf,MPI_DOUBLE_PRECISION,
!     &                rrank,tag,comm3d,
!     &                req(ireq,identif),ierr)

      end if
      end if

      end if

      do i = 1, ireq
        call MPI_WAIT(req2(i),status,ierr)
      enddo

!      call MPI_BARRIER(COMM3D, ierr)

!--------------------------------------------------------------

      if (prplc(1)==1.and.ansar(2)) then
        do j=nyi,nye
          do is=1,nxsh
            x(nxi-is,j,ze)=rxy_xpy0z0(j,is)
          end do
        end do
      endif
       
      if (prplc(2)==1.and.ansar(1)) then
        do j=nyi,nye
          do is=1,nxsh
            x(nxe+is,j,ze)=rxy_xmy0z0(j,is)
          end do
        end do
      endif
c
      if (prplc(3)==1.and.ansar(4)) then
        do is=1,nysh
          do i=nxi,nxe
           x(i,nyi-is,ze)=rxy_x0ypz0(i,is)
          end do
        end do
      endif

      if (prplc(4)==1.and.ansar(3)) then
        do is=1,nysh
          do i=nxi,nxe
           x(i,nye+is,ze)=rxy_x0ymz0(i,is)
          end do
        end do
      endif
c

c--------xy------------xy-------------xy-------------xy-------------
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      if (prplc(5)==1.and.ansar(8)) then
        do js=1,nysh
          do is=1,nxsh
            x(nxi-is,nyi-js,ze)=rxy_xpypz0(is,js)
          end do
        end do
      endif
c++++++++++++++++++++++++++++++--------------------------------------
      if (prplc(7)==1.and.ansar(6)) then
        do js=1,nysh
          do is=1,nxsh
            x(nxi-is,nye+js,ze)=rxy_xpymz0(is,js)
          end do
        end do
      endif
c---------------------------------++++++++++++++++++++++++++++++++++
      if (prplc(6)==1.and.ansar(7)) then
        do js=1,nysh
          do is=1,nxsh
            x(nxe+is,nyi-js,ze)=rxy_xmypz0(is,js)
          end do
        end do
      endif
c---------------------------------   --------------------------------
      if (prplc(8)==1.and.ansar(5)) then
        do js=1,nysh
          do is=1,nxsh
            x(nxe+is,nye+js,ze)=rxy_xmymz0(is,js)
          end do
        end do
      endif

!         CALL MPI_BARRIER(comm3d,ierr)
!#if timer
!        tmr2=MPI_WTIME()
!        tmr_exy = tmr_exy +tmr2-tmr1
!#endif

!        deallocate(xy_xpy0z0)
!        deallocate(xy_xmy0z0)
!        deallocate(xy_x0ypz0)
!        deallocate(xy_x0ymz0)
!                deallocate (xy_xpypz0)
!                deallocate (xy_xmypz0)
!                deallocate (xy_xpymz0)
!                deallocate (xy_xmymz0)
!        deallocate(rxy_xpy0z0)
!        deallocate(rxy_xmy0z0)
!        deallocate(rxy_x0ypz0)
!        deallocate(rxy_x0ymz0)
!                deallocate (rxy_xpypz0)
!                deallocate (rxy_xmypz0)
!                deallocate (rxy_xpymz0)
!                deallocate (rxy_xmymz0)

       if (firstcall) firstcall = .false.

       return
       END SUBROUTINE MPA_EXCHXY
c
           SUBROUTINE MPA_SYNC(comm3d,nproc,identif)
           implicit none
           include 'mpif.h'
           integer status(MPI_STATUS_SIZE)
           integer comm3d,myrank,ierr,identif,nproc
           integer ridentif
           integer lbuf,itag,tag
           integer il
           integer i
           integer it
           logical teqid,teqid1
           lbuf=1
           teqid=.false.
           call MPI_COMM_RANK(comm3d,myrank,ierr)
          il=0
          do while(.not.teqid)

           if(myrank.ne.0)then

           tag=myrank+2001
           CALL MPI_send(identif,lbuf,MPI_INTEGER,0,tag,comm3d,ierr)
           call MPI_RECV(il,lbuf,MPI_INTEGER,
     &                   0,tag,comm3d,status,ierr)
           teqid=il.eq.1
           else

           teqid=.true.
           do i = 1,nproc-1
           tag=i+2001
            call MPI_RECV(ridentif,lbuf,MPI_INTEGER,
     &                   i,tag,comm3d,status,ierr)
            teqid1=identif.eq.ridentif
            teqid=teqid.and.teqid1
            write(*,*)identif,ridentif,teqid,i
           enddo
           end if
           if(myrank.eq.0)then
           read(*,*)it
           do i = 1,nproc-1
           il=0
           if(teqid)il=1
           tag=i+2001
           CALL MPI_send(il,lbuf,MPI_INTEGER,i,tag,comm3d,ierr)
           enddo
           end if
           enddo
           write(*,*)'out logical',myrank,identif
           return
           end

!#endif
